;;;; Roguelib copyright 2010 Adam White theroguemonkey@gmail.com
;;;; Released under the GPL - refer included file COPYING

(in-package #:rllib)

;;;============================================================================
;;; Actor
;;;============================================================================

(defclass actor ()
  ((coords
    :initarg :coords
    :accessor @coords
    :initform (error "ACTOR coords must be specified"))
   (map
    :initarg :map
    :reader @map
    :initform (error "ACTOR map must be specified"))
   (next-action
    :initarg :next-action
    :reader @next-action
    :initform 0)))

(defgeneric act (actor)
  (:documentation "Causes an ACTOR to perform now"))

(defgeneric gender (actor)
  (:method ((actor actor))
    :neuter))

(defgeneric render-actor (actor))

;;;;============================================================================
;;;; Statistics
;;;;============================================================================

(defclass stat ()
  ((value
    :initarg :stat)
   (max
    :initarg :max)))




;;;============================================================================
;;; Creature base class
;;;============================================================================

(defclass mob (actor)
  ((name
    :initarg :name
    :accessor @name
    :initform "Bugsy")
   (size
    :initarg :size
    :accessor @size
    :initform 0)
   (reach
    :initarg :reach
    :accessor @reach
    :initform 1)
   (gender
    :initarg :gender
    :accessor gender
    :initform :male)
   (locomotion
    :initarg :locomotion
    :accessor locomotion
    :initform '(:walk))
   (render
    :initarg :render
    :accessor @render
    :initform nil)))


(defun make-mob (name type &key (reach 1) (size 1) (gender :male) (locomotion '(:walk)))
  (make-instance 'mob :name name :size size :reach reach :gender gender :locomotion locomotion
		 :render-list (make-output-texture type 0 0)))

(defmethod render-actor ((cr creature))
  
  )

;;;============================================================================
;;; Map funcs
;;;============================================================================

(defclass battlemap () 
  ((width
    :initarg :w
    :initform (error "MAP width must be specified")
    :reader map-width)
   (height
    :initarg :h
    :initform (error "MAP height must be specified")
    :reader map-height)
   (terrain
    :initform nil
    :accessor map-terrain)
   (mobs
    :initform nil
    :accessor map-mobs)
   (items
    :initform nil
    :accessor map-items)
   (tiles
    :accessor map-tiles
    :initform nil)
   (actors
    :initform (make-skiplist :key #'@next-action :test #'=)
    :accessor map-actors)))


(defmethod initialize-instance :after ((battlemap battlemap) &key w h fill)
  (with-slots (terrain mobs items) battlemap
    (setf terrain (make-array (list w h) :initial-element fill)
	  mobs (make-array (list w h) :initial-element nil)
	  items (make-array (list w h) :initial-element nil))))


(defun terrain-at (map coords) (terrain-at-* map (coords-x coords) (coords-y coords)))
(defun terrain-at-* (map x y)  (aref (map-terrain map) x y))
(defun mob-at (map coords) (mob-at-* map (coords-x coords) (coords-y coords)))
(defun mob-at-* (map x y) (aref (map-mobs map) x y))
(defun items-at (map coords) (items-at-* map (coords-x coords) (coords-y coords)))
(defun items-at-* (map x y) (aref (map-items map) x y))

(defmethod (setf @coords) (newpos (actor creature))
  (with-slots (map coords) actor
    (unless (equal coords newpos)
      (dolist (c (@allcoords actor))
	(setf (aref (map-mobs map) (coords-x c) (coords-y c)) nil)))
    (when newpos
      (let ((coords (collect-coords-square newpos (@size actor))))
	(setf (slot-value actor 'allcoords) coords)
	(dolist (c coords)
	  (setf (aref (map-mobs map) (coords-x c) (coords-y c)) actor))))))

(defmethod (setf @coords) ((newpos null) (actor creature))
  (skiplist-delete actor (map-actors (@map actor)))
  (call-next-method))

(defmethod (setf @next-action) (action (actor creature))
  (with-slots (map) actor
    (when (@next-action actor)
      (skiplist-delete actor (map-actors map)))
    (setf (slot-value actor 'next-action) action)
    (skiplist-insert actor (map-actors map))))

(defmethod (setf @next-action) ((action null) (actor creature))
  (setf (@coords actor) nil))

(defmethod next-actor ((map battlemap))
  (skiplist-front (map-actors map)))

(defun in-map-bounds-p (coords map)
  (and (< -1 (coords-x coords) (map-width map))
       (< -1 (coords-y coords) (map-height map))))

(defun passable-p (coords creature map)
  (let ((allcoords (collect-coords-square coords (@size creature)))
	(locomotion (locomotion creature)))
    (every #'(lambda (x)
	       (and (in-map-bounds-p x map)
		    (let ((cr (mob-at x map))) (or (null cr) (eq x cr)))
		    (terrain-passable (terrain-at x map) locomotion)))
	   allcoords)))

 (defun map-dimensions (map)
   (list (map-width map) (map-height map)))

;;;============================================================================
;;; Terrain
;;;============================================================================

(defun terrain-passable (terrain locomotion)
  (let ((passable-by (get terrain :passable-by nil)))
    (if (find :all passable-by :test #'eq)
	'(:all)
	(intersection passable-by (mklist locomotion) :test #'eq))))

(defun terrain-opaque (terrain)
  (get terrain :opaque nil))


;;;============================================================================
;;; Map Creators
;;;============================================================================  

(defun create-cave-map (width height empty fill empty-if-less fill-if-more fill-perc)
  (let ((map (make-array (list width height) :element-type 'bit))
	(tmp-map (make-array (list width height) :element-type 'bit))
	(real-map (make-instance 'battlemap :w width :h height :fill empty)))
    (dotimes (y height)
      (dotimes (x width)
	(setf (aref map x y) (if (< (random 100) fill-perc) 1 0))
	(setf (aref tmp-map x y) 0)))
    
    (labels ((at (coords)
	       (aref map (coords-x coords) (coords-y coords)))
	     (num-surrounding (x y)
	       (reduce #'+ (collect-bounded-coords-* (1- x) (1- y) (1+ x) (1+ y) width height) :key #'at)))

      (dotimes (iter 10)
	(dotimes (y height)
	  (dotimes (x width)
	    (let ((num (num-surrounding x y)))
	      (setf (aref tmp-map x y) (cond
					 ((< num empty-if-less) 0)
					 ((> num fill-if-more) 1)
					 (t (aref map  x y)))))))
	(rotatef map tmp-map)))

    ;; fill in the real map
    (dotimes (y height)
      (dotimes (x width)
	(when (or (plusp (aref map x y))
		  (zerop x)
		  (zerop y)
		  (= y (1- height))
		  (= x (1- width)))
	  (setf (aref (map-terrain real-map) x y) fill))))
    
    real-map))




;(defun create-dungeon-map (width height &key style)
;  )


  



;;;============================================================================
 ;;; FOV
;;;============================================================================

(defun opaque-p  (coords map)
  (terrain-opaque (terrain-at coords map)))

(defun opaque-p-* (x y map)
  (terrain-opaque (terrain-at-* x y map)))



    
			 
#||
(defun fov-map (coords map width height sight-radius viewing)
  (let* ((mult '(( 1 0 0  1) (0  1  1 0) (0 -1  1 0) (-1 0 0  1)
                 (-1 0 0 -1) (0 -1 -1 0) (0  1 -1 0) ( 1 0 0 -1)))

         (light-map (make-array (map-dimensions map) :element-type 'bit :initial-element 0))
         (viewport (make-array (list width height) :initial-element nil))
         (vis-start-x 0) (vis-start-y 0)
         (half-width (floor width 2))
         (half-height (floor height 2))
         (cx (car coords))
         (cy (cdr coords))
         (radius-squared (* sight-radius sight-radius))
         (map-start-x (- cx half-width)) 
         (map-start-y (- cy half-height))
         (map-end-x (min (+ cx half-width 1) (map-width map))) 
         (map-end-y (min (+ cy half-height) (map-height map))))

    (declare (type fixnum width height vis-start-x vis-start-y half-width half-height
		   sight-radius cx cy radius-squared map-start-x map-start-y
		   map-end-x map-end-y))
    (labels 
        ((set-lit (x y)
           "Mark a square as lit on map"
	   (setf (seen-at-* x y map) (display-symbol-at x y)))

         (blocked (x y)
           (opaque-p-* x y map viewing))

         ;; recursive shadowcasting
         (cast-light/r (row start end xx xy yx yy)
           "Recursive lightcasting function"
           (unless (< start end)
             (loop
                for j from row below sight-radius
                for dx = (- (1+ j)) 
                for dy = (- j)
                for blocked = nil
                for new-start = 0
                do (progn 
                     (loop 
                        for inc-dx = (incf dx)
                        for x = (+ cx (* dx xx) (* dy xy))
                        for y = (+ cy (* dx yx) (* dy yy))
                        for l-slope = (/ (- dx 0.5) (+ dy 0.5))
                        for r-slope = (/ (+ dx 0.5) (- dy 0.5))
                        while (and (<= dx 1) (<= end l-slope))
                        do (when (and (>= start r-slope)
                                      (in-map-bounds-p x y))
                             (when (< (+ (* dx dx) (* dy dy)) radius-squared)
                               (set-lit x y))
                             (if blocked
                                 (if (blocked x y)
                                     (setf new-start r-slope)
                                     (setf blocked nil start new-start))
                                 (when (and (blocked x y) (<= j sight-radius))
                                   (setf blocked t new-start r-slope)
                                   (cast-light/r (1+ j) start l-slope
                                                 xx xy yx yy)))))
                     (when blocked
                       (loop-finish)))))))
                           
      ;; clamp viewport size
      (when (minusp map-start-x)
	(setf vis-start-x (- map-start-x)
	      map-start-x 0))
      (when (minusp map-start-y)
	(setf vis-start-y (- map-start-y)
	      map-start-y 0))
      (set-lit cx cy)
      (dolist (m mult)
	(apply #'cast-light/r 1 1.0 0.0 m))
    
      (loop 
	 for my from map-start-y below map-end-y
	 for vy from vis-start-y below height
	 do (loop 
	       for mx from map-start-x below map-end-x
	       for vx from vis-start-x below width
	       do (setf (aref viewport vx vy)
			(if (plusp (aref light-map mx my))
			    (aref *hero-map* mx my)
			    (bwhen seen (aref *hero-map* mx my)
				   (cons (aref *hero-map* mx my) :black))))))
      (setf *hero-lit-map* light-map)
      viewport)))



||#